Linux Cubed Series 3: Developer Tools/Linux Cubed Series 3 - Developer Tools.iso/devel/lang/lisp/guile-ii.src/guile-ii/guile-src/gls/Gmodules.scm

Text File | 1995-08-03 | 14.5 KB | 497 lines

;;;;     Copyright (C) 1994, 1995 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;;

;; by Miles Bader ([e-mail])
;; and Tom Lord ([e-mail])
;;



;;; {Error Handling}
;;;
;;; This is the error handler used by the low-level module system.
;;; It has its own name so that calls are easy to find and change
;;; later once we know what we are doing.
;;;


(define guile:error error)


;;; {Low Level Modules}
;;;
;;; These are the low level data structures for modules.
;;;
;;; (make-module size use-list lazy-binding-proc) => module
;;; module-{obarray,uses,binder}[|-set!]
;;; (module? obj) => [#t|#f]
;;; (module-locally-bound? module symbol) => [#t|#f]
;;; (module-bound? module symbol) => [#t|#f]
;;; (module-symbol-locally-interned? module symbol) => [#t|#f]
;;; (module-symbol-interned? module symbol) => [#t|#f]
;;; (module-local-variable module symbol) => [#<variable ...> | #f]
;;; (module-variable module symbol) => [#<variable ...> | #f]
;;; (module-symbol-binding module symbol opt-value)
;;;        => [ <obj> | opt-value | an error occurs ]
;;; (module-make-local-var! module symbol) => #<variable...>
;;; (module-add! module symbol var) => unspecified
;;; (module-remove! module symbol) =>  unspecified
;;; (module-for-each proc module) => unspecified
;;; the-symhash-module ; a module wrapper for the built-in top level
;;; (make-scm-module) => module ; a lazy copy of the symhash module
;;; (set-current-module module) => unspecified
;;; (current-module) => #<module...>
;;;
;;;


;;; {and-map, or-map, and map-in-order}
;;;
;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
;;; (map-in-order fn lst) is like (map fn lst) but definately in order of lst.
;;;

;; and-map f l
;;
;; Apply f to successive elements of l until exhaustion or f returns #f.
;; If returning early, return #f.  Otherwise, return the last value returned
;; by f.  If f has never been called because l is empty, return #t.
;;
(define (and-map f lst)
  (let loop ((result #t)
         (l lst))
    (and result
     (or (and (null? l)
          result)
         (loop (f (car l)) (cdr l))))))

;; or-map f l
;;
;; Apply f to successive elements of l until exhaustion or while f returns #f.
;; If returning early, return the return value of f.
;;
(define (or-map f lst)
  (let loop ((result #f)
         (l lst))
    (or result
    (and (not (null? l))
         (loop (f (car l)) (cdr l))))))

;; map-in-order
;;
;; Like map, but guaranteed to process the list in order.
;;
(define (map-in-order fn l)
  (if (null? l)
      '()
      (cons (fn (car l))
        (map-in-order fn (cdr l)))))

;; DEFINE-MACRO
;;
;; A more schemey version of scm's common-lispy defmacro.  Should also be
;; more module-safe.
;;
(defmacro define-macro (first . rest)
  (let ((name (if (symbol? first) first (car first)))
    (transformer
     (if (symbol? first)
         (car rest)
         `(lambda ,(cdr first) ,@rest))))
    `(define ,name
    (,(lambda (transformer)
        (set! *defmacros* (acons name transformer *defmacros*))
          (defmacro:transformer transformer))
     ,transformer))))

;; This is how modules are printed.
;; You can re-define it.
;;
(define (%print-module mod port wr?)
  (display "#<" port)
  (display (or (module-kind mod) "module") port)
  (let ((name (module-name mod)))
    (if name
    (begin
      (display " " port)
      (display name port))))
  (display " " port)
  (display (number->string (object-address mod) 16) port)
  (display ">" port))

;; module-type
;;
;; A module is characterized by an obarray in which local symbols
;; are interned, a list of modules, "uses", from which non-local
;; bindings can be inherited, and an optional lazy-binder which
;; is a (THUNK module symbol) which, as a last resort, can provide
;; bindings that would otherwise not be found locally in the module.
;;
(define module-type
  (make-record-type 'module '(obarray uses binder eval-thunk name kind)
            (lambda (mod port wr?)
              (%print-module mod port wr?))))

;; make-module &opt size uses
;;
;; Create a new module, perhaps with a particular size of obarray
;; or initial uses list.
;;
(define module-constructor (record-constructor module-type))

(define make-module
    (lambda args
      (let* ((size 1021)
         (uses '())
         (binder #f)
         (answer #f)
         (eval-thunk
          (lambda (symbol define?)
        (if define?
            (module-make-local-var! answer symbol)
            (module-variable answer symbol)))))

    (if (> (length args) 0)
        (begin
          (set! size (or (car args) size))
          (set! args (cdr args))))

    (if (> (length args) 0)
        (begin
          (set! uses (or (car args) uses))
          (set! args (cdr args))))

    (if (> (length args) 0)
        (begin
          (set! binder (or (car args) binder))
          (set! args (cdr args))))

    (if (not (null? args))
        (guile:error "Too many args to make-module." args))

    (if (not (integer? size))
        (guile:error "Illegal size to make-module." size))

    (and (list? uses)
         (or (and-map module? uses)
         (guile:error "Incorrect use list." uses)))

    (if (and binder (not (procedure? binder)))
        (guile:error
         "Lazy-binder expected to be a procedure or #f." binder))

    (set! answer
          (module-constructor (make-vector size '())
                  uses
                  binder
                  eval-thunk
                  #f
                  #f))
    answer)))

(define module-obarray  (record-accessor module-type 'obarray))
(define module-obarray-set! (record-modifier module-type 'obarray))
(define module-uses  (record-accessor module-type 'uses))
(define module-uses-set! (record-modifier module-type 'uses))
(define module-binder (record-accessor module-type 'binder))
(define module-binder-set! (record-modifier module-type 'binder))
(define module-eval-thunk (record-accessor module-type 'eval-thunk))
(define module-eval-thunk-set! (record-modifier module-type 'eval-thunk))
(define module-name (record-accessor module-type 'name))
(define module-set-name! (record-modifier module-type 'name))
(define module-kind (record-accessor module-type 'kind))
(define module-set-kind! (record-modifier module-type 'kind))
(define module? (record-predicate module-type))


;;; {Module Searching in General}
;;;
;;; We sometimes want to look for properties of a symbol
;;; just within the obarray of one module.  If the property
;;; holds, then it is said to hold ``locally'' as in, ``The symbol
;;; DISPLAY is locally rebound in the module `safe-guile'.''
;;;
;;;
;;; Other times, we want to test for a symbol property in the obarray
;;; of M and, if it is not found there, try each of the modules in the
;;; uses list of M.  This is the normal way of testing for some
;;; property, so we state these properties without qualification as
;;; in: ``The symbol 'fnord is interned in module M because it is
;;; interned locally in module M2 which is a member of the uses list
;;; of M.''
;;;

;; module-search fn m
;;
;; return the first non-#f result of FN applied to M and then to
;; the modules in the uses of m, and so on recursively.  If all applications
;; return #f, then so does this function.
;;
(define (module-search fn m v)
  (define (loop pos)
    (and (pair? pos)
     (or (module-search fn (car pos) v)
         (loop (cdr pos)))))
  (or (fn m v)
      (loop (module-uses m))))


;;; {Is a symbol bound in a module?}
;;;
;;; Symbol S in Module M is bound if S is interned in M and if the binding
;;; of S in M has been set to some well-defined value.
;;;

;; module-locally-bound? module symbol
;;
;; Is a symbol bound (interned and defined) locally in a given module?
;;
(define (module-locally-bound? m v)
  (let ((var (module-local-variable m v)))
    (and var
     (variable-bound? var))))

;; module-bound? module symbol
;;
;; Is a symbol bound (interned and defined) anywhere in a given module
;; or its uses?
;;
(define (module-bound? m v)
  (module-search module-locally-bound? m v))

;;; {Is a symbol interned in a module?}
;;;
;;; Symbol S in Module M is interned if S occurs in
;;; of S in M has been set to some well-defined value.
;;;
;;; It is possible to intern a symbol in a module without providing
;;; an initial binding for the corresponding variable.  This is done
;;; with:
;;;       (module-add! module symbol (make-undefined-variable))
;;;
;;; In that case, the symbol is interned in the module, but not
;;; bound there.  The unbound symbol shadows any binding for that
;;; symbol that might otherwise be inherited from a member of the uses list.
;;;

;; module-symbol-locally-interned? module symbol
;;
;; is a symbol interned (not neccessarily defined) locally in a given module
;; or its uses?  Interned symbols shadow inherited bindings even if
;; they are not themselves bound to a defined value.
;;
(define (module-symbol-locally-interned? m v)
  (symbol-interned? (module-obarray m) v))


;; module-symbol-interned? module symbol
;;
;; is a symbol interned (not neccessarily defined) anywhere in a given module
;; or its uses?  Interned symbols shadow inherited bindings even if
;; they are not themselves bound to a defined value.
;;
(define (module-symbol-interned? m v)
  (module-search module-symbol-locally-interned? m v))


;;; {Mapping modules x symbols --> variables}
;;;

;; module-local-variable module symbol
;; return the local variable associated with a MODULE and SYMBOL.
;;
;;; This function is very important. It is the only function that can
;;; return a variable from a module other than the mutators that store
;;; new variables in modules.  Therefore, this function is the location
;;; of the "lazy binder" hack.
;;;
;;; If symbol is defined in MODULE, and if the definition binds symbol
;;; to a variable, return that variable object.
;;;
;;; If the symbols is not found at first, but the module has a lazy binder,
;;; then try the binder.
;;;
;;; If the symbol is not found at all, return #f.
;;;
(define (module-local-variable m v)
  (or (and (module-symbol-locally-interned? m v)
       (let ((b (symbol-binding (module-obarray m) v)))
         (and (variable? b) b)))
      (and (module-binder m)
       ((module-binder m) m v))))

;; module-variable module symbol
;;
;; like module-local-variable, except search the uses in the
;; case V is not found in M.
;;
(define (module-variable m v)
  (module-search module-local-variable m v))


;;; {Mapping modules x symbols --> bindings}
;;;
;;; These are similar to the mapping to variables, except that the
;;; variable is dereferenced.
;;;

;; module-symbol-binding module symbol opt-value
;;
;; return the binding of a variable specified by name within
;; a given module, signalling an guile:error if the variable is unbound.
;; If the OPT-VALUE is passed, then instead of signalling an guile:error,
;; return OPT-VALUE.
;;
(define (module-symbol-local-binding m v . opt-val)
  (let ((var (module-local-variable m v)))
    (if var
    (variable-ref var)
    (if (not (null? opt-val))
        (car opt-val)
        (guile:error "Locally unbound variable." v)))))

;; module-symbol-binding module symbol opt-value
;;
;; return the binding of a variable specified by name within
;; a given module, signalling an guile:error if the variable is unbound.
;; If the OPT-VALUE is passed, then instead of signalling an guile:error,
;; return OPT-VALUE.
;;
(define (module-symbol-binding m v . opt-val)
  (let ((var (module-variable m v)))
    (if var
    (variable-ref var)
    (if (not (null? opt-val))
        (car opt-val)
        (guile:error "Unbound variable." v)))))



;;; {Adding Variables to Modules}
;;;
;;;


;; module-make-local-var! module symbol
;;
;; ensure a variable for V in the local namespace of M.
;; If no variable was already there, then create a new and uninitialzied
;; variable.
;;
(define (module-make-local-var! m v)
  (or (module-local-variable m v)
      (begin
    (intern-symbol (module-obarray m) v)
    (let ((answer (make-undefined-variable v)))
      (symbol-set! (module-obarray m) v answer)
      answer))))

;; module-add! module symbol var
;;
;; ensure a particular variable for V in the local namespace of M.
;;
(define (module-add! m v var)
  (if (not (variable? var))
      (guile:error "Bad variable to module-add!" var))
  (intern-symbol (module-obarray m) v)
  (symbol-set! (module-obarray m) v var))


;; module-remove!
;;
;; make sure that a symbol is undefined in the local namespace of M.
;;
(define (module-remove! m v)
  (unintern-symbol (module-obarray m) v))

;; MODULE-FOR-EACH -- exported
;;
;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE).
;;
(define (module-for-each proc module)
  (let ((obarray (module-obarray module)))
    (do ((index 0 (+ index 1))
     (end (vector-length obarray)))
    ((= index end))
      (for-each
       (lambda (bucket)
     (proc (car bucket) (cdr bucket)))
       (vector-ref obarray index)))))


;;; {Low Level Bootstrapping}
;;;

;; make-scm-module

;; An scm module is a module into which the lazy binder copies variable
;; bindings from the symhash table.  Newly introduced bindings
;; are local to this module.   They are not reflected in the symhash
;; table.
;;
(define (make-scm-module)
  (make-module 1019 #f
           (lambda (m s)
         (let ((bi (and (symbol-interned? #f s)
                (builtin-variable s))))
           (and bi
            (variable-bound? bi)
            bi)))))

(define the-default-module (make-scm-module))

(define default-uses (list the-default-module))

;; the-module
;;
;; the module used by the normalizer to resolve free variables
;;
(define the-module the-default-module)

;; set-current-module module
;;
;; set the current module as viewed by the normalizer.
;;
(define (set-current-module m)
  (set! the-module m)
  (set! *top-level-lookup-thunk* (and m (module-eval-thunk m)))
  #t)


;; current-module
;;
;; return the current module as viewed by the normalizer.
;;
(define (current-module) the-module)


;;; {How to Load the User Module System}
;;;

(define (use-modules)
  (for-each
   (lambda (name)
     (load (in-vicinity (implementation-vicinity) name (scheme-file-suffix))))
   '("modops" "extlibs" "libguile" "defmod"))
  (set-current-module *load-module*))

(define (gscm-create-top-level) #f)
(define (gscm-destroy-top-level it) #f)